(*
  Copyright (c) 2009 Barry Schwartz

  Permission is hereby granted, free of charge, to any person
  obtaining a copy of this software and associated documentation
  files (the "Software"), to deal in the Software without
  restriction, including without limitation the rights to use,
  copy, modify, merge, publish, distribute, sublicense, and/or sell
  copies of the Software, and to permit persons to whom the
  Software is furnished to do so, subject to the following
  conditions:

  The above copyright notice and this permission notice shall be
  included in all copies or substantial portions of the Software.

  THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
  EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
  OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
  NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
  HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
  WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
  FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
  OTHER DEALINGS IN THE SOFTWARE.
*)

(*-----------------------------------------------------------------------*)

open Array
open FontForge
open Pycaml
open Python_tools
open XNum

(*-----------------------------------------------------------------------*)

module Tag =
struct
  include Int32

  let nibblemask_bits = of_int 0xF

  let nibblemask tag  = to_int (logand nibblemask_bits tag)
  let nibbleshift tag = shift_right_logical tag 4
  let nibbleblock     = 16

  let compose_tag high low =
    Int32.logor (Int32.shift_left (Int32.of_int high) 16)
      (Int32.of_int low)

  let make s =
    if String.length s <> 4 then
      invalid_arg "Tag.make: 4 characters expected"
    else
      let d0 = int_of_char s.[0] in
      let d1 = int_of_char s.[1] in
      let d2 = int_of_char s.[2] in
      let d3 = int_of_char s.[3] in
        if d0 >= 32 && d0 <= 126 &&
          d1 >= 32 && d1 <= 126 &&
          d2 >= 32 && d2 <= 126 &&
          d3 >= 32 && d3 <= 126 then
            compose_tag ((d0 lsl 8) lor d1) ((d2 lsl 8) lor d3)
        else
          invalid_arg "Tag.make: invalid character"

  let make_from_ints s_uc = (* Make from an array of ASCII or Unicode integers. *)
    if Array.length s_uc <> 4 then
      invalid_arg "make_from_uc: 4 characters expected"
    else
      let d0 = s_uc.(0) in
      let d1 = s_uc.(1) in
      let d2 = s_uc.(2) in
      let d3 = s_uc.(3) in
        if d0 >= 32 && d0 <= 126 &&
          d1 >= 32 && d1 <= 126 &&
          d2 >= 32 && d2 <= 126 &&
          d3 >= 32 && d3 <= 126 then
            compose_tag ((d0 lsl 8) lor d1) ((d2 lsl 8) lor d3)
        else
          invalid_arg "Tag.make_from_uc: invalid character"

  let str tag =
    let s = String.make 4 ' ' in
    let x = Int32.to_int (Int32.logand (Int32.shift_right tag 16) (Int32.of_int 0xffff)) in
    let y = Int32.to_int (Int32.logand tag (Int32.of_int 0xffff)) in
      s.[0] <- char_of_int ((x lsr 8) land 0xff);
      s.[1] <- char_of_int (x land 0xff);
      s.[2] <- char_of_int ((y lsr 8) land 0xff);
      s.[3] <- char_of_int (y land 0xff);
      s

  let compare : t -> t -> int = compare

end                                     (* module Tag *)

module TagMap = Nibbletrie.Make(Tag)

(*-----------------------------------------------------------------------*)  

module GID =
struct
  type t = int (* with sexp *)

  let nibblemask gid  = gid land 0xF
  let nibbleshift gid = gid lsr 4
  let nibbleblock     = 16

  external of_int : int -> t = "%identity"
  external to_int : t -> int = "%identity"
  let compare = compare
  let succ gid = gid + 1
  let print gid = print_int (to_int gid)

  let pythonize = pyint_fromint
  let unpythonize = guarded_pyint_asint
end

module GIDMap  = Nibbletrie.Make(GID)
module GIDSet  = Nibbleset.Make(GID)

(*-----------------------------------------------------------------------*)

type value_record = {
  (* Device-table fields are not supported. *)
  x_placement_adj : int;
  y_placement_adj : int;
  x_advance_adj   : int;
  y_advance_adj   : int;
}


type lookup_type =

  | DummyLookup

    (* GPOS *)
  | SingleAdjustmentLookup
  | PairAdjustmentLookup
  | CursiveAttachmentLookup
  | MarkToBaseAttachmentLookup
  | MarkToLigatureAttachmentLookup
  | MarkToMarkAttachmentLookup
  | ContextPositioningLookup
  | ChainedContextPositioningLookup
  | ExtensionPositioningLookup

      (* GSUB *)
  | SingleSubstitutionLookup
  | MultipleSubstitutionLookup
  | AlternateSubstitutionLookup
  | LigatureSubstitutionLookup
  | ContextSubstitutionLookup
  | ChainingContextSubstitutionLookup
  | ExtensionSubstitutionLookup
  | ReverseChainingContextSubstitutionLookup

type chaining_context_subst_format3 = {
  backtrack_coverage : GIDSet.t list;
  input_coverage     : GIDSet.t list;
  lookahead_coverage : GIDSet.t list;
  lookup_indexes     : (int * int) list;
}
and subtable =
    | SingleSubstitutionSubtable of GID.t GIDMap.t
    | LigatureSubstitutionSubtable of (GID.t list * GID.t) list GIDMap.t
    | ChainingContextSubstitution3Subtable of chaining_context_subst_format3
    | SingleAdjustmentSubtable of value_record GIDMap.t
    | PairAdjustmentSubtable of (value_record option * value_record option) GIDMap.t GIDMap.t
    | ClassBasedKerningSubtable of (int * int GIDMap.t * int GIDMap.t * int array)

and lookup_table = {
  lookupType          : lookup_type;
  rightToLeft         : bool;
  ignoreBaseGlyphs    : bool;
  ignoreLigatures     : bool;
  ignoreMarks         : bool;
  useMarkFilteringSet : bool;
  markAttachmentType  : int;
  subTables           : subtable list;
}

(* FIX: Feature parameters are not yet implemented. *)
type feature_parameters = NoFeatureParameters (* with sexp *)

type feature_table = {
  featureTag        : Tag.t;
  featureParams     : feature_parameters;
  lookupListIndexes : int list;
} (* with sexp *)

(* FIX: Re-ordering tables are not yet implemented. *)
type reordering_table = NoReorderingTable (* with sexp *)

type langsys_table = {
  lookupOrder : reordering_table;
  reqFeature  : feature_table option;
  features    : feature_table list;
} (* with sexp *)

type gsub_or_gpos = {
  langSysTable    : langsys_table;
  lookupListArray : lookup_table array (* FIX: We don't need a separate lookup array for each langsys. *)
} (* with sexp *)

let unpythonize_feature_table =
  unpythonizing_function
    [| DictType |]
    (fun py_args ->
       let py_d = py_args.(0) in
         { featureTag = Tag.make (unpythonize_string (pydict_getitemstring (py_d, "featureTag")));
           featureParams = NoFeatureParameters; (* Feature parameters currently are not implemented. *)
           lookupListIndexes = unpythonize_list guarded_pyint_asint (pydict_getitemstring (py_d, "lookupListIndexes")) })

let unpythonize_langsys_table =
  unpythonizing_function
    [| DictType |]
    (fun py_args ->
       let py_d = py_args.(0) in
         { lookupOrder = NoReorderingTable; (* Reordering tables currently are not implemented. *)
           reqFeature = unpythonize_option unpythonize_feature_table (pydict_getitemstring (py_d, "reqFeature"));
           features = unpythonize_list unpythonize_feature_table (pydict_getitemstring (py_d, "features"))})

let get_feature_tables table_name ff_font script langsys =
  let kt_ot_features = py_module "kt.ot_features" in
  let args = pytuple4 (FFfont.pythonize ff_font, pythonize_string table_name,
                       pyint_fromint (Tag.to_int script),
                       pyint_fromint (Tag.to_int langsys)) in
  let py_feature_tables = py_module_call kt_ot_features "get_feature_tables" args in
    unpythonize_langsys_table py_feature_tables

let unpythonize_lookup_type =
  unpythonizing_function
    [| EitherStringType |]
    begin
      fun py_args ->
        match unpythonize_string py_args.(0) with
          | "SingleSubstitutionLookup" -> SingleSubstitutionLookup
          | "MultipleSubstitutionLookup" -> MultipleSubstitutionLookup
          | "AlternateSubstitutionLookup" -> AlternateSubstitutionLookup
          | "LigatureSubstitutionLookup" -> LigatureSubstitutionLookup
          | "ContextSubstitutionLookup" -> ContextSubstitutionLookup
          | "ChainingContextSubstitutionLookup" -> ChainingContextSubstitutionLookup
          | "ReverseChainingContextSubstitutionLookup" -> ReverseChainingContextSubstitutionLookup
          | "SingleAdjustmentLookup" -> SingleAdjustmentLookup
          | "PairAdjustmentLookup" -> PairAdjustmentLookup
          | "CursiveAttachmentLookup" -> CursiveAttachmentLookup
          | "MarkToBaseAttachmentLookup" -> MarkToBaseAttachmentLookup
          | "MarkToLigatureAttachmentLookup" -> MarkToLigatureAttachmentLookup
          | "MarkToMarkAttachmentLookup" -> MarkToMarkAttachmentLookup
          | "ContextPositioningLookup" -> ContextPositioningLookup
          | "ChainedContextPositioningLookup" -> ChainedContextPositioningLookup
          | _ -> assert false
    end

let unpythonize_GID_tuple unpythonizer =
  unpythonizing_function
    ~expect_tuple:true
    [| IntType; AnyType |]
    (fun py_args -> (GID.unpythonize py_args.(0), unpythonizer py_args.(1)))

let unpythonize_GIDMap unpythonizer =
  unpythonizing_function
    [| DictType |]
    (fun py_args ->
       let py_list = pydict_items py_args.(0) in
       let caml_list = unpythonize_list (unpythonize_GID_tuple unpythonizer) py_list in
         GIDMap.of_list caml_list)

let unpythonize_GIDSet =
  unpythonizing_function
    [| AnyType |]             (* FIX: Add SetType support to pycaml *)
    (fun py_args ->
       let py_list = pysequence_list py_args.(0) in
       let caml_list = unpythonize_list GID.unpythonize py_list in
         GIDSet.of_elements caml_list)

let unpythonize_value_record =
  unpythonizing_function
    ~expect_tuple:true
    [| IntType; IntType; IntType; IntType |]
    (fun py_args ->
       { x_placement_adj = pyint_asint py_args.(0);
         y_placement_adj = pyint_asint py_args.(1);
         x_advance_adj   = pyint_asint py_args.(2);
         y_advance_adj   = pyint_asint py_args.(3) })

let unpythonize_value_record_pair =
  unpythonizing_function
    ~expect_tuple:true
    [| AnyType; AnyType |]
    (fun py_args ->
       (unpythonize_option unpythonize_value_record py_args.(0),
        unpythonize_option unpythonize_value_record py_args.(1)))

let unpythonize_single_lig =
  unpythonizing_function
    ~expect_tuple:true
    [| ListType; IntType |]
    (fun py_args ->
       (unpythonize_list GID.unpythonize py_args.(0),
        GID.unpythonize py_args.(1)))

let unpythonize_lig_data =
  unpythonizing_function
    [| ListType |]
    (fun py_args -> unpythonize_list unpythonize_single_lig py_args.(0))

let unpythonize_chainsub_format3 =
  unpythonizing_function
    [| DictType |]
    (fun py_args ->
       let py_d = py_args.(0) in
         { backtrack_coverage = unpythonize_list unpythonize_GIDSet (pydict_getitemstring (py_d, "backtrack_coverage"));
           input_coverage = unpythonize_list unpythonize_GIDSet (pydict_getitemstring (py_d, "input_coverage"));
           lookahead_coverage = unpythonize_list unpythonize_GIDSet (pydict_getitemstring (py_d, "lookahead_coverage"));
           lookup_indexes = unpythonize_list unpythonize_int_tuple (pydict_getitemstring (py_d, "lookup_indexes")) })

let unpythonize_class_kern =
  unpythonizing_function
    ~expect_tuple:true
    [| IntType; DictType; DictType; ListType |]
    (fun py_args ->
       (pyint_asint py_args.(0),
        unpythonize_GIDMap guarded_pyint_asint py_args.(1),
        unpythonize_GIDMap guarded_pyint_asint py_args.(2),
        unpythonize_array guarded_pyint_asint py_args.(3)))

let unpythonize_single_sub = unpythonize_GIDMap GID.unpythonize
let unpythonize_lig_sub    = unpythonize_GIDMap unpythonize_lig_data
let unpythonize_single_adj = unpythonize_GIDMap unpythonize_value_record
let unpythonize_pair_adj   = unpythonize_GIDMap (unpythonize_GIDMap unpythonize_value_record_pair)

let unpythonize_subtable =
  unpythonizing_function
    ~expect_tuple:true
    [| EitherStringType; AnyType |]
    begin
      fun py_args ->
        match unpythonize_string py_args.(0) with
          | "SingleSubstitutionSubtable" ->
              SingleSubstitutionSubtable (unpythonize_single_sub py_args.(1))
          | "LigatureSubstitutionSubtable" ->
              LigatureSubstitutionSubtable (unpythonize_lig_sub py_args.(1))
          | "ChainingContextSubstitution3Subtable" ->
              ChainingContextSubstitution3Subtable (unpythonize_chainsub_format3 py_args.(1))
          | "SingleAdjustmentSubtable" ->
              SingleAdjustmentSubtable (unpythonize_single_adj py_args.(1))
          | "PairAdjustmentSubtable" ->
              PairAdjustmentSubtable (unpythonize_pair_adj py_args.(1))
          | "ClassBasedKerningSubtable" ->
              ClassBasedKerningSubtable (unpythonize_class_kern py_args.(1))
          | _ -> assert false
    end

let unpythonize_lookup_table =
  unpythonizing_function
    [| DictType |]
    (fun py_args ->
       let py_d = py_args.(0) in
         { lookupType = unpythonize_lookup_type (pydict_getitemstring (py_d, "lookupType"));
           rightToLeft = unpythonize_bool (pydict_getitemstring (py_d, "rightToLeft"));
           ignoreBaseGlyphs = unpythonize_bool (pydict_getitemstring (py_d, "ignoreBaseGlyphs"));
           ignoreLigatures = unpythonize_bool (pydict_getitemstring (py_d, "ignoreLigatures"));
           ignoreMarks = unpythonize_bool (pydict_getitemstring (py_d, "ignoreMarks"));
           useMarkFilteringSet = unpythonize_bool (pydict_getitemstring (py_d, "useMarkFilteringSet"));
           markAttachmentType = guarded_pyint_asint (pydict_getitemstring (py_d, "markAttachmentType"));
           subTables = unpythonize_list unpythonize_subtable (pydict_getitemstring (py_d, "subTables")) })

let get_lookup_list table_name ff_font =
  let kt_ot_features = py_module "kt.ot_features" in
  let args = pytuple2 (FFfont.pythonize ff_font, pythonize_string table_name) in
  let py_feature_tables = py_module_call kt_ot_features "get_lookup_list" args in
    unpythonize_array unpythonize_lookup_table py_feature_tables

let make_gsub_or_gpos_table table_name ff_font script langsys =
  { langSysTable = get_feature_tables table_name ff_font script langsys;
    lookupListArray = get_lookup_list table_name ff_font }

let make_gsub_table = make_gsub_or_gpos_table "GSUB"
let make_gpos_table = make_gsub_or_gpos_table "GPOS"

let unpythonize_tag_pair =
  unpythonizing_function
    ~expect_tuple:true
    [| EitherStringType; EitherStringType |]
    (fun py_args ->
       (Tag.make (unpythonize_string py_args.(0)),
        Tag.make (unpythonize_string py_args.(1))))

let unpythonize_language_systems =
  unpythonizing_function
    [| ListType |]
    (fun py_args -> unpythonize_list unpythonize_tag_pair py_args.(0))

let make_langsys_restricter ff_font =
  let dflt_script = Tag.make "DFLT" in
  let dflt_lang = Tag.make "dflt" in
  let kt_ot_features = py_module "kt.ot_features" in
  let args = pytuple_fromsingle (FFfont.pythonize ff_font) in
  let py_systems = py_module_call kt_ot_features "get_all_language_systems" args in
  let systems = unpythonize_language_systems py_systems in
    (fun script lang ->
       if not (List.exists (fun (scr, _) -> script = scr) systems) then
         (dflt_script, dflt_lang) (* Note that this won’t work if the font has no DFLT script. *)
       else if not (List.exists (fun (scr, lng) -> script = scr && lang = lng) systems) then
         (script, dflt_lang)
       else
         (script, lang))

(*-----------------------------------------------------------------------*)

(* Represent feature combinations as vectors of 'marks' corresponding
   to activated lookups. *)
module LookupMarks :
sig
  type t (* with sexp *)
  val make_from_indexes : int -> int list -> t
  val indexes : t -> int list
  val union   : t -> t -> t
end =
struct
  type t = string (* with sexp *)

  let make_from_indexes size index_list =
    let marks = String.make size '\000' in
      List.iter (fun i -> marks.[i] <- '\001') index_list;
      marks

  let indexes marks =
    (* Build the list from high indexes down to low, so the indexes
       end up in order of increasing value (which is the correct order in
       which to evaluate lookups). *)
    let rec build_list p i =
      if i < 0 then
        p
      else
        let c = marks.[i] in
          if c = '\000' then
            build_list p (i - 1)
          else
            build_list (i :: p) (i - 1)
    in
      build_list [] (String.length marks - 1)

  let union a b =
    let length = String.length a in
    let result = String.make length '\000' in
      for i = 0 to length - 1 do
        if a.[i] <> '\000' || b.[i] <> '\000' then
          result.[i] <- '\001';
      done;
      result

end                                     (* module LookupMarks *)

module LookupMarker :
sig
  type t (* with sexp *)
  val make_gsub : FFfont.t -> Tag.t -> Tag.t -> t
  val make_gpos : FFfont.t -> Tag.t -> Tag.t -> t
  val make_from_table : gsub_or_gpos option -> t
  val dummy     : t
  val marks     : t -> Tag.t list -> LookupMarks.t
  val lookups   : t -> lookup_table array
end =
struct
  type t = {
    lookup_array  : lookup_table array;
    default_marks : LookupMarks.t;
    tags_to_marks : LookupMarks.t TagMap.t;
  } (* with sexp *)

  let dummy = {
    lookup_array = [||];
    default_marks = LookupMarks.make_from_indexes 0 [];
    tags_to_marks = TagMap.empty;
  }

  let make ot_table =
    let lookups = ot_table.lookupListArray in
    let size = Array.length lookups in
      try
        let langsys = ot_table.langSysTable in
        let default_marks =
          match langsys.reqFeature with
            | None ->
                LookupMarks.make_from_indexes size []
            | Some feature ->
                LookupMarks.make_from_indexes size feature.lookupListIndexes
        in
        let bind tag indexes map =
          let marks = LookupMarks.make_from_indexes size indexes in
            TagMap.add tag marks map
        in
        let the_map =
          List.fold_left
            (fun map feature -> bind feature.featureTag feature.lookupListIndexes map)
            TagMap.empty
            langsys.features
        in
          { lookup_array  = lookups;
            default_marks = default_marks;
            tags_to_marks = the_map }
      with
        | Not_found -> dummy

  let make_gsub ff_font script_tag langsys_tag =
    let ot_table = make_gsub_table ff_font script_tag langsys_tag in
      make ot_table

  let make_gpos ff_font script_tag langsys_tag =
    let ot_table = make_gpos_table ff_font script_tag langsys_tag in
      make ot_table

  let make_from_table ot_table =
    match ot_table with
      | None       -> dummy
      | Some table -> make table

  let marks marker tags =
    let unite_one_tag m tag =
      try
        LookupMarks.union m (TagMap.find tag marker.tags_to_marks)
      with
        | Not_found -> m
    in
      List.fold_left unite_one_tag marker.default_marks tags

  let lookups marker =
    marker.lookup_array

end                                     (* module LookupMarker *)

(*-----------------------------------------------------------------------*)

module MarkerRepository :
sig
  type t (* with sexp *)
  val create    : unit -> t
  val put       : t -> LookupMarker.t -> Tag.t -> Tag.t -> unit
  val put_gsub  : t -> FFfont.t -> Tag.t -> Tag.t -> unit
  val put_gpos  : t -> FFfont.t -> Tag.t -> Tag.t -> unit
  val get       : t -> Tag.t -> Tag.t -> LookupMarker.t
end =
struct
  type t = (Tag.t * Tag.t, LookupMarker.t) Hashtbl.t (* with sexp *)

  let create () = Hashtbl.create 5

  let put repository marker script lang =
      Hashtbl.replace repository (script, lang) marker

  let put_gsub repository ff_font script lang =
    let marker = LookupMarker.make_gsub ff_font script lang in
      put repository marker script lang

  let put_gpos repository ff_font script lang =
    let marker = LookupMarker.make_gpos ff_font script lang in
      put repository marker script lang

  let get repository script lang =
    Hashtbl.find repository (script, lang)
end

(*-----------------------------------------------------------------------*)

exception Bad_FeatureSet_spec of string

let default_features = ["kern"; "liga"; "calt"; "clig"; "ccmp"; "locl"]

module FeatureSet :
sig
  type t (* with sexp *)
  val empty      : t
  val default    : t
  val change_one : t -> string -> t
  val change     : t -> string list -> t
  val marks      : t -> LookupMarker.t -> LookupMarks.t
end =
struct
  type t = Tag.t list (* with sexp *)

  let empty = []

  let add tag feature_set =
    tag :: (List.filter ((<>) tag) feature_set)

  let remove tag feature_set =
    List.filter ((<>) tag) feature_set

  (* "+feat" = "feat+" = "feat" -> turn the feature on
     "-feat" = "feat-"          -> turn the feature off *)
  let change_one feature_set change_spec =
    if String.length change_spec = 4 then
      let tag = Tag.make change_spec in
        add tag feature_set

    else if String.length change_spec = 5 && String.contains "+-" (String.get change_spec 0) then
      let tag = Tag.make (String.sub change_spec 1 4) in
        match String.get change_spec 0 with
          | '+' -> add tag feature_set
          | '-' -> remove tag feature_set
          |  _  -> assert false
    else if String.length change_spec = 5 && String.contains "+-" (String.get change_spec 4) then
      let tag = Tag.make (String.sub change_spec 0 4) in
        match String.get change_spec 4 with
          | '+' -> add tag feature_set
          | '-' -> remove tag feature_set
          |  _  -> assert false
    else
      raise (Bad_FeatureSet_spec ("\"" ^ change_spec ^ "\""))

  let rec change feature_set =
    function
      | [] -> feature_set
      | head :: tail ->
          change (change_one feature_set head) tail

  let default = List.map Tag.make default_features

  let marks feature_set marker =
    LookupMarker.marks marker feature_set

end                                     (* module FeatureSet *)

(*-----------------------------------------------------------------------*)
